perm filename SOLITA[1,BGB] blob
sn#057499 filedate 1973-08-11 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00011 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 ALTERNATE PDP-10 MNEMONICS.
C00005 00003 SAIL LIKE SUBROUTINE LINKAGE.
C00008 00004 TITLE SOLITA - JMC SOLITAIRE - B.G.BAUMGART - 10 AUGUST 1973.
C00010 00005 MAIN EXECUTION.
C00012 00006 SUBR(LEGAL,Q) SKIP WHEN MOVE IS ILLEGAL.
C00014 00007 SUBR(TRY)
C00016 00008 SUBR(RANDOM)
C00020 00009 SUBR(SHUFFL)
C00022 00010 SUBR(DECDPY,INTEGER) DECIMAL NUMBER DISPLAY.
C00024 00011 SUBR(REALIN)
C00027 ENDMK
C⊗;
;ALTERNATE PDP-10 MNEMONICS.
DEFINE O(A,B){OPDEF A[B]}
O LIP,HLR↔O LAP,HRR↔O DIP,HRLM↔O DAP,HRRM
O ZIP,HRRZS↔O ZAP,HLLZS↔O WIP,HRROS↔O WAP,HRRZS
O CAR,HLRZ↔O LIPI,HRLI↔O LAPI,HRRI↔O DIPZ,HRLZM
O CDR,HRRZ↔O LACI,MOVEI↔O SLACI,MOVSI↔O DAPZ,HRRZM
O LAC,MOVE↔O LACN,MOVN↔O LACM,MOVM↔O SLAC,MOVS
O DAC,MOVEM↔O DACN,MOVNM↔O DACM,MOVMM↔O SDAC,MOVSM
O NIP,HLRE↔O NAP,HRRE↔O NIM,HRREI↔O GO,JRST
O DZM,SETZM↔O DOM,SETOM↔O ZAC,SETZ↔O WAC,SETO
O FLOAT,FSC 233↔O FLO,FSC 225↔O FIXX,FIX 233000
;MAKE RAID KNOW THE FOLLOWING
O(FIX,FIX)↔O(HALT,HALT)
O(INCHRW,INCHRW)↔O(INCHWL,{051200000000})
O(OUTCHR,OUTCHR)↔O(OUTSTR,OUTSTR)
O(JRSTF,{JRST 2,})↔O(JCALL,{JRST 1,})↔O(PGCLR,{PGIOT 2,})
;RETURN FROM AN N-ARGUMENT SUBROUTINE CALL.
↓P←←17↔DEFINE POP0J <POPJ P,>
↓POP1J.:SUB P,[2(2)]↔GO@2(P)↔DEFINE POP1J<GO POP1J.>
↓POP2J.:SUB P,[3(3)]↔GO@3(P)↔DEFINE POP2J<GO POP2J.>
↓POP3J.:SUB P,[4(4)]↔GO@4(P)↔DEFINE POP3J<GO POP3J.>
↓POP4J.:SUB P,[5(5)]↔GO@5(P)↔DEFINE POP4J<GO POP4J.>
;ACCUMULATOR AND TEMPORARY DATA MANAGEMENT.
DEFINE ACCUMULATORS(LIST){ACPTR←←2 ;DECLARE ACCUMULATORS.
FOR AC⊂(LIST)<AC←ACPTR↔ACPTR←←ACPTR+1↔>}
FOR @$ I←0,16<AC.$I←I↔> ;ACCUMULATOR NAMES FOR RAID.
DEFINE DECLARE (LIST){
FOR VARNAM⊂(LIST)<VARNAM:0↔>}
DEFINE CRLF{OUTSTR[BYTE(7)15,12]}
;SAIL LIKE SUBROUTINE LINKAGE.
DEFINE ARG1<-1(P)>↔DEFINE ARG2<-2(P)>
DEFINE ARG3<-3(P)>↔DEFINE ARG4<-4(P)>
DEFINE CAT $(A,B){A$B} ;CONCATENATION.
.PLEVEL←←0 ;PDL BACK POINTER.
.SLEVEL←←0 ;DEPTH OF NESTED SUBROUTINE DECLARATIONS.
;SUBROUTINE DECLARATION MACROS - SUBR & ENDR.
;(Reminder: Right-arrow, "→" is FAIL's macro arg EVAL).
DEFINE SUBR(NAME,X1,X2,X3,X4,X5)↔{BEGIN NAME↔INTERN NAME
GLOBAL .PLEVEL↔GLOBAL .SLEVEL↔.SLEVEL←←.SLEVEL+1
CAT(.SBR,→.SLEVEL)←←.PLEVEL ↔.PLEVEL←←.PLEVEL+1
IFDIF<><X1>{DEFARG(X1,→.PLEVEL) ↔.PLEVEL←←.PLEVEL+1
IFDIF<><X2>{DEFARG(X2,→.PLEVEL) ↔.PLEVEL←←.PLEVEL+1
IFDIF<><X3>{DEFARG(X3,→.PLEVEL) ↔.PLEVEL←←.PLEVEL+1
IFDIF<><X4>{DEFARG(X4,→.PLEVEL) ↔.PLEVEL←←.PLEVEL+1
IFDIF<><X5>{DEFARG(X5,→.PLEVEL) ↔.PLEVEL←←.PLEVEL+1}}}}}
XWD 777000+.PLEVEL-CAT(.SBR,→.SLEVEL)-1,[SIXBIT|NAME|]↔↓NAME:;}
;DEFINE ARGUMENT NAME MACRO.
DEFINE DEFARG(NAME,LEVEL){DEFINE NAME{LEVEL-.PLEVEL(17)}}
;SUBROUTINE TERMINATION MACRO.
DEFINE ENDR{.PLEVEL←←CAT(.SBR,→.SLEVEL)
.SLEVEL←←.SLEVEL-1↔LIT↔BLOCK 0↔BEND }
;SUBROUTINE CALLING MACROS - CALL & SETQ.
DEFINE CALL(NAME,X1,X2,X3,X4,X5)
{GLOBAL .SLEVEL,.PLEVEL↔.SLEVEL←←.SLEVEL+1
CAT(.SBR,→.SLEVEL)←←.PLEVEL
IFDIF<><X1>{PUSH P,X1↔.PLEVEL←.PLEVEL+1
IFDIF<><X2>{PUSH P,X2↔.PLEVEL←.PLEVEL+1
IFDIF<><X3>{PUSH P,X3↔.PLEVEL←.PLEVEL+1
IFDIF<><X4>{PUSH P,X4↔.PLEVEL←.PLEVEL+1
IFDIF<><X5>{PUSH P,X5↔.PLEVEL←.PLEVEL+1 }}}}}
IFDIF<><NAME>{PUSHJ P,NAME }
.PLEVEL←←CAT(.SBR,→.SLEVEL)↔.SLEVEL←←.SLEVEL-1}
DEFINE SETQ(VAR,LIST){CALL(LIST)↔DAC 1,VAR}
;STACK ACCESSING MACROS - PUSHP & POPP.
DEFINE PUSHP(ARG){PUSH P,ARG↔.PLEVEL←←.PLEVEL+1}
DEFINE POPP(ARG) {POP P,ARG↔.PLEVEL←←.PLEVEL-1}
TITLE SOLITA - JMC SOLITAIRE - B.G.BAUMGART - 10 AUGUST 1973.
ACCUMULATORS{S0,S1,S2,S3,S4,P1,P2,P3,P4,A1,B1,A2,B2}
;INPUT DECK.
DECK0: -1
DECK: BLOCK =52
CNT: 0 ;MOVE COUNTER.
;TEMPORARY STACKS.
STAK1: -1↔BLOCK =52
STAK2: -1↔BLOCK =52
STAK3: -1↔BLOCK =52
STAK4: -1↔BLOCK =52
;OUTPUT PILES.
PILE1: -1↔ 0↔ 1↔ 2↔ 3↔ 4↔ 5↔ 6↔ 7↔ 8↔ 9↔=10↔=11↔=12
PILE2: -1↔ 1↔ 3↔ 5↔ 7↔ 9↔=11↔ 0↔ 2↔ 4↔ 6↔ 8↔=10↔=12
PILE3: -1↔ 2↔ 5↔ 8↔=11↔ 1↔ 4↔ 7↔=10↔ 0↔ 3↔ 6↔ 9↔=12
PILE4: -1↔ 3↔ 7↔=11↔ 2↔ 6↔=10↔ 1↔ 5↔ 9↔ 0↔ 4↔ 8↔=12
;TABLE FOR CONVERTING BINARY TO HALFY.
TAB1: XWD S1,P1↔XWD S1,P2↔XWD S1,P3↔XWD S1,P4
XWD S2,P1↔XWD S2,P2↔XWD S2,P3↔XWD S2,P4
XWD S3,P1↔XWD S3,P2↔XWD S3,P3↔XWD S3,P4
XWD S4,P1↔XWD S4,P2↔XWD S4,P3↔XWD S4,P4
XWD S0,S1↔XWD S0,S2↔XWD S0,S3↔XWD S0,S4
;MAIN EXECUTION.
PDL: BLOCK =2000
SA: LACI =1000↔DAC CNT3
DZM CNT1↔DZM CNT2
REPLAY: SOSGE CNT3↔GO ENDUP
LAC P,[XWD -=2000,PDL]
LACI =104↔DAC CNT ;GAME HAS EXACTLY =104 MOVES.
CALL(SHUFFL)
;INITIALIZE THE POINTERS.
LAC S0,[XWD =52,DECK+=51]
LACI S1,STAK1↔LACI P1,PILE1
LACI S2,STAK2↔LACI P2,PILE2
LACI S3,STAK3↔LACI P3,PILE3
LACI S4,STAK4↔LACI P4,PILE4
CALL(TRY)
LOSER: AOS CNT1↔GO REPLAY
WINNER: AOS CNT2↔GO REPLAY
ENDUP:
CRLF↔CRLF
OUTCHR[9]↔CALL(DECDPY,CNT1)↔OUTSTR[ASCIZ/ GAMES LOST.
/]↔ OUTCHR[9]↔CALL(DECDPY,CNT2)↔OUTSTR[ASCIZ/ GAMES WON.
/]↔ INCHRW↔GO SA
CNT1: 0
CNT2: 0
CNT3: 0
SUBR(LEGAL,Q) ;SKIP WHEN MOVE IS ILLEGAL.
COMMENT ⊗------------------------------------------------------------
⊗↔
ACCUMULATORS{S0,S1,S2,S3,S4,P1,P2,P3,P4,A1,B1,A2,B2}
CAR A1,Q↔LAC A2,(A1) ;SOURCE AC# AND PDLPTR.
CDR B1,Q↔LAC B2,(B1) ;DESTIN AC# AND PDLPTR.
;IS SOURCE EMPTY ?
DPB A1,[POINT 4,.+1,12]
TLNN 0,-1↔GO L2 ;EXIT NO CARD AT SOURCE.
;IS DESTINATION A PILE ?
LAC(A2) ;GET SOURCE CARD
CAIGE B1,P1↔GO L3
CAME 1(B2) ;COMPARE SOURCE WITH DESTINATION+1.
L2: AOS(P)↔POP1J
;DESTINATION IS A STACK.
L3: ADDI 0,TAB2
CAME B1,@0
AOS(P)↔POP1J
ENDR LEGAL;8/11/73(BGB)----------------------------------------------
; 0 1 2 3 4 5 6 7 8 9 10 11 12 ←←CARD.
TAB2: S2↔S1↔S1↔S1↔S2↔S1↔S3↔S2↔S3↔S3↔S3↔S2↔S4; ←←STACK.
SUBR(TRY)
COMMENT ⊗------------------------------------------------------------
⊗
PUSH P,[-1]↔LACI 1,=20
;GENERATE LEGAL MOVES AND PUSH THEM INTO THE STACK.
L1: SOJL 1,L2
CALL(LEGAL,{TAB1(1)})
PUSH P,TAB1(1)↔GO L1
;ARE THERE ANY POSSIBLE MOVES LEFT.
L2: SKIPGE(P)↔GO[POP P,0↔POP0J] ;EXIT TRIES EXHAUSTED.
;MOVE A CARD.
MOV: CAR(P)↔DPB[POINT 4,.+3,12]
CDR(P)↔DPB[POINT 4,.+2,12]
POP↔PUSH
;CONTINUE GAME BELOW THIS PLY.
SOSG CNT↔JCALL WINNER ;TEST FOR END OF GAME - WIN.
CALL(TRY)
;UN-MOVE.
CDR(P)↔DPB[POINT 4,.+5,12]
CAR(P)↔DPB[POINT 4,.+4,12]
CAIN S0↔GO LOSER ;TEST FOR END OF GAME - LOSE.
POP↔PUSH↔AOS CNT
POP P,0
GO L2
ENDR TRY;8/11/73(BGB)------------------------------------------------
SUBR(RANDOM)
COMMENT ⊗------------------------------------------------------------
⊗
SKIPE RANFLG↔GO L1 ;TEST WHETHER WE ARE INIT'ED.
;INITIALIZE ARRAY RAN5 0 TO =255.
SETOM RANFLG
HRLZI 1,-=256↔LACI 3
IMULI 3↔AND[017777777777] ;RAN5[I] ← RAN2 ←(RAN2*3)MOD 2↑31.
DAC RAN5(1)↔AOBJN 1,.-3
DAC RAN2↔LACI 1↔DAC RAN1 ;RAN1 ← 1.
L1: LAC 1,RAN2↔MULI 1,=1756 ;RAN1 ← (RAN2*1756)MOD 8191.
IDIVI 2,=8191↔DAC 3,RAN1
LAC 1,RAN1↔ASH 1,-5 ;RAN3 ← RAN1/32.
CAILE 1,=256↔ANDI 1,377
DAC 1,RAN3
LAC RAN5(1)↔DAC RAN4 ;RAN4 ← RAN5[RAN3];
LAC RAN2
IMULI 3↔AND[017777777777] ;RAN5[I] ← RAN2 ←(RAN2*3)MOD 2↑31.
DAC RAN5(1)↔DAC RAN2
LAC 1,RAN4↔ASH 1,-5↔FSC 1,201 ;FLOAT TO REAL BETWEEN 0 AND 1.
POP0J
DECLARE{RANFLG,RAN1,RAN2,RAN3,RAN4}
RAN5: BLOCK =256
ENDR RANDOM;8/10/73(BGB)---------------------------------------------
SUBR(SHUFFL)
COMMENT ⊗------------------------------------------------------------
Initialize the input deck and shuffle it by calling RANDOM
52 times, placing the cards in the four low order bits, and then
sorting the deck.⊗
I ←← 16 ↔ J ←← 15
;GET 52 RANDOM NUMBER BETWEEN 0.0 AND 1.0 FLOATING.
LACI I,=51 ;52 CARDS TO A DECK.
SLACI J,-=13 ;13 CARDS TO A SUIT.
L1: CALL(RANDOM)
DPB J,[POINT 4,1,35]
AOBJN J,.+2↔SLACI J,-=13 ;BUMP THE CARD VALUE.
DAC 1,DECK(I)
SOJGE I,L1
;BUBBLE SORT THE CARDS.
ZAC I,
L2: LACI J,1(I)↔LAC DECK(I)
L3: CAMG DECK(J)↔GO .+3
EXCH DECK(J)↔DAC DECK(I)
CAIGE J,=51↔AOJA J,L3
CAIGE I,=50↔AOJA I,L2
;MASK THE CARDS.
LAC I,[XWD -=52,DECK]↔LACI 17
ANDM(I)↔AOBJN I,.-1
POP0J
ENDR SHUFFL;8/10/73(BGB)---------------------------------------------
SUBR(DECDPY,INTEGER) ;DECIMAL NUMBER DISPLAY.
LAC 1,INTEGER↔POPP -1(P) ;FETCH ARG AND LAC RET. ADR.
L1: JUMPGE 1,L2 ;TEST FOR NEGATIVE NUMBER.
MOVM 2,1↔OUTCHR["-"] ;PRINT MINUS SIGN.
LAC 1,2
L2: IDIVI 1,12↔PUSH P,2 ;MODULO TEN AND SAVE.
SKIPE 1↔PUSHJ P,L2 ;TEST FOR DONE.
POP P,1↔ADDI 1,60↔OUTCHR 1 ;RESTORE & PRINT.
POP0J
ENDR DECDPY;12/17/72(BGB)--------------------------------------------
SUBR(FLODPY,FLONUM,PLACES) ;FLOATING NUMBER DISPLAY.
LAC FLONUM
JUMPL[OUTCHR["-"]↔LACM FLONUM↔GO .+1]
LACM 2,PLACES↔CAILE 2,6↔LACI 2,6↔DAC 2,PLACES
FMPR[1.↔10.↔100.↔1000.↔10000.↔100000.↔1000000.](2)↔FIXX
IDIV[=1↔=10↔=100↔=1000↔=10000↔=100000↔=1000000](2)
PUSHP 1↔CALL(DECDPY,0)↔POPP 0
LAC 2,PLACES
ADD[=1↔=10↔=100↔=1000↔=10000↔=100000↔=1000000](2)
OUTCHR["."]↔CALL(DECDPY,0)
POP2J
ENDR FLODPY;12/17/72(BGB)--------------------------------------------
SUBR(REALIN)
COMMENT ⊗------------------------------------------------------------
<EXPR> ::= <EXPR>+<TERM>|<EXPR>-<TERM>|<TERM>
<TERM> ::= <TERM>*<PRIMARY>|<TERM>/<PRIMARY>|<PRIMARY>
<PRIMARY> ::= -<PRIMARY>|(<EXPR>)|π|<REAL NUMBER>
⊗
CALL(TERM)↔CAIN 1,"+"
GO [ PUSH P,0↔CALL(TERM)
FADR 0,(P)↔SUB P,[XWD 1,1]↔GO REALIN+1 ]
CAIN 1,"-"
GO [ PUSH P,0↔CALL(TERM)
MOVN 0,0↔FADR 0,(P)↔SUB P,[XWD 1,1]↔GO REALIN+1 ]
CAIN 1,15↔INCHWL 1
POP0J↔POP0J
TERM: CALL(PRIMARY)
TERM2: CAIN 1,"*"↔GO [ PUSH P,0↔CALL(PRIMARY)
FMPR 0,(P)↔SUB P,[XWD 1,1]↔GO TERM2 ]
CAIN 1,"/"↔GO [ PUSH P,0↔CALL(PRIMARY)
EXCH 0,(P)↔FDVR 0,(P)↔SUB P,[XWD 1,1]
GO TERM2 ]
POP0J
COMMENT ⊗ Input small real number.
AC-0 INTEGER ACCUMULATION. AC-0 RETURNS REAL NUMBER.
AC-1 CHARACTER. AC-1 RETURNS BREAK CHARACTER.
AC-2 COUNTER OF DIGITS TO RIGHT OF DECIMAL POINT PLUS ONE.
AC-3 MINUS SIGN FLAG.
⊗
PRIMARY:SETZ↔SETZB 2,3
L0: INCHWL 1
CAIN 1," "↔GO .-2
CAIN 1,"-"↔GO[SETCMM 3↔GO L0]
CAIN 1,"π"↔GO[MOVE 0,[3.14159628]
GETRET: INCHWL 1↔GO L3]
CAIN 1,"("↔GO[PUSH P,3↔CALL(REALIN)↔POP P,3
CAIN 1,")"↔GO GETRET
OUTSTR[ASCIZ/WARNING: MISSING ')'
/]↔ POP0J]
SKIPA
L1: INCHWL 1
CAIE 1,"."↔GO .+3↔JUMPN 2,L2↔AOJA 2,L1
CAIL 1,"0"↔CAILE 1,"9"↔GO L2
JUMPN 2,[CAILE 2,4↔GO L1↔AOJA 2,.+1]
ANDI 1,17↔IMULI =10↔ADD 1↔GO L1
L2: FLOAT↔SOSLE 2↔FDVR[1.0↔10.0↔100.0↔1000.0↔10000.0](2)
L3: SKIPE 3↔MOVNS↔POP0J
ENDR REALIN;12/16/72(BGB),14-MAR-73(TVR)-----------------------------
END SA